home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / inliner.arc / INLINER.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1985-07-25  |  43.4 KB  |  1,429 lines
  1. {IN THE PUBLIC DOMAIN BUT COPYRIGHTED BY
  2.                 ANTHONY M MARCY
  3.                 AVAILABLE ON   "THE PROGRAMMERS' TOOLBOX" BBS
  4.                                301-540-7230, 24 HRS (DATA)
  5.  
  6.  PLEASE DO NOT DISTRIBUTE THIS WITHOUT THE FILE INLINER.DOC!!!
  7.  (NONE OF THE ABOVE WAS INSERTED BY A M MARCY, BUT BY THE
  8.  USER WHO SPLIT THE DOC FILE OUT & PUT IT ALL IN THE .ARC FILE.)
  9.  
  10. program inliner;
  11.  
  12. const
  13.   tsize = 200;     { size of symbol table }
  14.  
  15. type
  16.   filename = string[20];
  17.   opcode = (nul,
  18.             mov,push,pop,xchg,in_,out,xlat,lea,lds,les,lahf,sahf,pushf,
  19.             popf,add,adc,inc,sub,sbb,dec,neg,cmp,aas,das,mul,imul,aam,div_,
  20.             idiv,aad,cbw,cwd,not_,shl_,sal,shr_,sar,rol,ror,rcl,rcr,and_,
  21.             test_,or_,xor_,aaa,daa,rep,repe,repz,repne,repnz,movs,cmps,scas,
  22.             lods,stos,call,jmp,ret,je,jz,jl,jnge,jle,jng,jb,jnae,jbe,jna,jp,
  23.             jpe,jo,js,jne,jnz,jnl,jge,jnle,jg,jnb,jae,jnbe,ja,jnp,jpo,jno,jns,
  24.             loop,loopz,loope,loopnz,loopne,jcxz,int,into,iret,
  25.             clc,cmc,stc,cld,std,cli,sti,hlt,wait,esc,lock,nop,
  26.             valid,
  27.             assume,comment,db,dd,dq,dt,dw,end_,equ,even,extrn,group,include,
  28.             label_,name,org,proc,public,record_,segment,struc,macro,endm,
  29.             page,subttl,title,
  30.             fld,fst,fstp,fxch,fcom,fcomp,fcompp,ftst,fxam,fadd,fsub,fmul,fdiv,
  31.             fsqrt,fscale,fprem,frndint,fxtract,fabs,fchs,fptan,fpatan,f2xm1,
  32.             fyl2x,fyl2xp1,fldz,fld1,fldpi,fldl2t,fldl2e,fldlg2,fldln2,finit,
  33.             feni,fdisi,fldcw,fstcw,fstsw,fclex,fstenv,fldenv,fsave,frstor,
  34.             fincstp,fdecstp,ffree,fnop,fwait,
  35.             last);
  36.   regs = (firstreg,ax,bx,cx,dx,sp,bp,si,di,al,bl,cl,dl,ah,bh,ch,dh,
  37.           ds,ss,cs,es,lastreg);
  38.   line = string[80];
  39.   idtype = string[20];
  40.   attr = record                   { attributes of an operand }
  41.            isop: boolean;
  42.            isaddr: boolean;
  43.            isid: boolean;
  44.            isconst: boolean;
  45.            value: integer;
  46.            isreg: boolean;
  47.            issreg: boolean;
  48.            rg: regs;
  49.            isimmed: boolean;
  50.            isidx,isbase: boolean;
  51.            idx,base: regs;
  52.            isbyte,isword: boolean;
  53.            isshort,isnear,isfar: boolean;
  54.            ident: idtype;
  55.          end;
  56.   cptr = ^codrec;
  57.   codrec = record                  { intermediate form of a line of code }
  58.              next: cptr;
  59.              labeln: integer;
  60.              op: opcode;
  61.              op1,op2: attr;
  62.              repx: opcode;
  63.              lockx: boolean;
  64.              override: regs;
  65.              source: line;
  66.              errn: byte;
  67.            end;
  68.   charset = set of char;
  69.  
  70. var
  71.   reg: array[regs] of string[2];             { register mnemonics }
  72.   rn: array[regs] of 0..7;                   { register numbers   }
  73.   mn: array[opcode] of string[6];            { opcode mnemonics   }
  74.   tab: array[0..tsize] of record             { symbol table }
  75.                             id: idtype;
  76.                             val: integer;
  77.                           end;
  78.   src,targ: text;                       { source and target files }
  79.   errn,pass: byte;                      { error #, pass # }
  80.   atstart,ok: boolean;
  81.   t: string[132];                       { target line }
  82.   loc: integer;          { location counter }
  83.   tcnt: integer;         { number of entries in symbol table }
  84.   n: integer;            { index into symbol table }
  85.   oldlen: integer;
  86.   firstentry: cptr;      { points to first line of intermediate code }
  87.   codpnt: cptr;          { points to current line of intermediate code }
  88.  
  89.   op: opcode;
  90.   op1,op2: attr;
  91.   repx: opcode;
  92.   lockx: boolean;
  93.   override: regs;
  94.  
  95.  
  96. procedure error(j: integer);    { only the first error in a line is recorded }
  97.  
  98. begin
  99.   if errn = 0 then errn := j;
  100. end;
  101.  
  102. procedure message;         { print error messages }
  103.  
  104. begin
  105.   if errn <> 0
  106.   then begin
  107.     ok := false;
  108.     t := t + '***';
  109.     case errn of
  110.      1: t := t + 'NOT ENOUGH OPERANDS';
  111.      2: t := t + 'INVALID OPERAND';
  112.      3: t := t + 'TYPE CONFLICT';
  113.      4: t := t + 'INVALID OPCODE';
  114.      5: t := t + 'INVALID REGISTER';
  115.      6: t := t + 'SYNTAX ERROR';
  116.      7: t := t + 'TYPE NOT SPECIFIED';
  117.      8: t := t + 'ILLEGAL REGISTER';
  118.      9: t := t + 'ERROR IN CONSTANT';
  119.     10: t := t + 'ILLEGAL OPERAND';
  120.     11: t := t + 'TOO MANY OPERANDS';
  121.     12: t := t + 'CONSTANT TOO BIG';
  122.     13: t := t + 'DUPLICATE PREFIX';
  123.     14: t := t + 'IDENTIFIER TOO LONG';
  124.     15: t := t + 'DUPLICATE LABEL';
  125.     16: t := t + 'UNDEFINED LABEL';
  126.     17: t := t + 'LABEL TOO FAR';
  127.     18: t := t + 'NOT IMPLEMENTED';
  128.   { 29: system error }
  129.  
  130.     else t := t + 'SYSTEM ERROR';
  131.     end;
  132.     t := t + '***'
  133.   end
  134. end;
  135.  
  136. function stupcase(st: idtype): idtype;
  137.  
  138. var i: integer;
  139.  
  140. begin
  141.   for i := 1 to length(st) do
  142.     st[i] := upcase(st[i]);
  143.   stupcase := st
  144. end;  { stupcase }
  145.  
  146. procedure startup;       { input names of source and target files }
  147.  
  148. var
  149.   exists: boolean;
  150.   inf,outf,tempstr: filename;
  151.   commandline: string[127] absolute cseg:$80;
  152.   params: string[127];
  153.   default: byte;
  154.  
  155.   procedure chkinf;             { does source file exist? }
  156.   begin
  157.     inf := stupcase(inf);
  158.     if pos('.',inf) = 0
  159.     then inf := inf + '.ASM';
  160.     assign(src,inf);
  161.     {$I-} reset(src) {$I+} ;            { if so, open it }
  162.     exists := (ioresult = 0);
  163.     if pos(':',inf) = 0
  164.     then inf := chr(default+65) + ':' + inf;
  165.     if not exists
  166.     then writeln('File ', inf, ' not found');
  167.   end;
  168.  
  169.   procedure chkoutf;               { is target filename valid? }
  170.   begin
  171.     outf := stupcase(outf);
  172.     assign(targ,outf);
  173.     {$I-} rewrite(targ) {$I+} ;         { if so, open it }
  174.     exists := (ioresult = 0);
  175.     if pos(':',outf) = 0
  176.     then outf := chr(default+65) + ':' + outf;
  177.     if not exists
  178.     then writeln('can''t open file ',outf);
  179.   end;
  180.  
  181. begin
  182.   inf := ''; outf := ''; params := commandline;
  183.   Inline(
  184.      $B4/$19                    { MOV AH,=$19 }
  185.     /$CD/$21                    { INT =$21    }
  186.     /$88/$86/default );         { MOV [BP]default,AL }
  187.   while (params <> '') and (params[1] = ' ') do
  188.     delete(params,1,1);
  189.   if params <> ''
  190.   then begin                                       { command line parameters }
  191.     while (params <> '') and (params[1] <> ' ') do begin
  192.       inf := inf + params[1];
  193.       delete(params,1,1); end;
  194.     chkinf;
  195.     if not exists then begin
  196.       commandline := '';
  197.       startup; end
  198.     else begin
  199.       writeln('Source file: ',inf);
  200.       while (params <> '') and (params[1] = ' ') do
  201.         delete(params,1,1);
  202.       if params <> ''
  203.       then while (params <> '') and (params[1] <> ' ') do begin
  204.         outf := outf + params[1];
  205.         delete(params,1,1); end
  206.       else outf := copy(inf,1,pos('.',inf)) + 'PAS';
  207.       chkoutf;
  208.       if not exists then begin
  209.         commandline := '';
  210.         startup; end
  211.       else writeln('Target file: ',outf);
  212.       end;
  213.     end
  214.   else begin                                        { prompt for filenames }
  215.     repeat
  216.       write('  Source file [.ASM] ? '); readln(inf);
  217.       chkinf;
  218.     until exists;
  219.     tempstr := copy(inf,1,pos('.',inf)) + 'PAS';
  220.     repeat
  221.       repeat
  222.         write('  Target file [',tempstr,'] ? ');
  223.         readln(outf); outf := stupcase(outf);
  224.       until inf <> outf;
  225.       if outf = '' then outf := tempstr;
  226.       chkoutf;
  227.     until exists;
  228.     end;
  229.   writeln;
  230. end;  { startup }
  231.  
  232. procedure init;               { initialize tables }
  233.  
  234. begin
  235.   mn[mov ] := 'MOV' ;   mn[push] := 'PUSH';   mn[pop ] := 'POP' ;
  236.   mn[xchg] := 'XCHG';   mn[in_ ] := 'IN'  ;   mn[out ] := 'OUT' ;
  237.   mn[xlat] := 'XLAT';   mn[lea ] := 'LEA' ;   mn[lds ] := 'LDS' ;
  238.   mn[les ] := 'LES' ;   mn[lahf] := 'LAHF';   mn[pushf] := 'PUSHF';
  239.   mn[sahf] := 'SAHF';   mn[popf] := 'POPF';   mn[add ] := 'ADD' ;
  240.   mn[adc ] := 'ADC' ;   mn[inc ] := 'INC' ;   mn[sub ] := 'SUB' ;
  241.   mn[sbb ] := 'SBB' ;   mn[dec ] := 'DEC' ;   mn[cmp ] := 'CMP' ;
  242.   mn[aas ] := 'AAS' ;   mn[das ] := 'DAS' ;   mn[mul ] := 'MUL' ;
  243.   mn[imul] := 'IMUL';   mn[aam ] := 'AAM' ;   mn[div_] := 'DIV' ;
  244.   mn[idiv] := 'IDIV';   mn[aad ] := 'AAD' ;   mn[cbw ] := 'CBW' ;
  245.   mn[cwd ] := 'CWD' ;   mn[aaa ] := 'AAA' ;   mn[daa ] := 'DAA' ;
  246.   mn[not_] := 'NOT' ;   mn[shl_] := 'SHL' ;   mn[sal ] := 'SAL' ;
  247.   mn[shr_] := 'SHR' ;   mn[sar ] := 'SAR' ;   mn[rol ] := 'ROL' ;
  248.   mn[ror ] := 'ROR' ;   mn[rcl ] := 'RCL' ;   mn[rcr ] := 'RCR' ;
  249.   mn[and_] := 'AND' ;   mn[or_ ] := 'OR'  ;   mn[test_] := 'TEST';
  250.   mn[xor_] := 'XOR' ;   mn[rep ] := 'REP' ;   mn[repne] := 'REPNE';
  251.   mn[repe] := 'REPE';   mn[repz] := 'REPZ';   mn[repnz] := 'REPNZ';
  252.   mn[movs] := 'MOVS';   mn[neg ] := 'NEG' ;   mn[nop ] := 'NOP' ;
  253.   mn[cmps] := 'CMPS';   mn[scas] := 'SCAS';   mn[lods] := 'LODS';
  254.   mn[stos] := 'STOS';   mn[call] := 'CALL';   mn[jmp ] := 'JMP' ;
  255.   mn[ret ] := 'RET' ;   mn[je  ] := 'JE'  ;   mn[jz  ] := 'JZ'  ;
  256.   mn[jl  ] := 'JL'  ;   mn[jnge] := 'JNGE';   mn[jle ] := 'JLE' ;
  257.   mn[jng ] := 'JNG' ;   mn[jb  ] := 'JB'  ;   mn[jnae] := 'JNAE';
  258.   mn[jbe ] := 'JBE' ;   mn[jna ] := 'JNA' ;   mn[jp  ] := 'JP'  ;
  259.   mn[jpe ] := 'JPE' ;   mn[jo  ] := 'JO'  ;   mn[js  ] := 'JS'  ;
  260.   mn[jne ] := 'JNE' ;   mn[jnz ] := 'JNZ' ;   mn[jnl ] := 'JNL' ;
  261.   mn[jge ] := 'JGE' ;   mn[jnle] := 'JNLE';   mn[jg  ] := 'JG'  ;
  262.   mn[jnb ] := 'JNB' ;   mn[jae ] := 'JAE' ;   mn[jnbe] := 'JNBE';
  263.   mn[ja  ] := 'JA'  ;   mn[jnp ] := 'JNP' ;   mn[jpo ] := 'JPO' ;
  264.   mn[jno ] := 'JNO' ;   mn[jns ] := 'JNS' ;   mn[loopz ] := 'LOOPZ' ;
  265.   mn[loop] := 'LOOP';   mn[jcxz] := 'JCXZ';   mn[loopnz] := 'LOOPNZ';
  266.   mn[int ] := 'INT' ;   mn[into] := 'INTO';   mn[loope ] := 'LOOPE' ;
  267.   mn[iret] := 'IRET';   mn[clc ] := 'CLC' ;   mn[loopne] := 'LOOPNE';
  268.   mn[cmc ] := 'CMC' ;   mn[stc ] := 'STC' ;   mn[cld ] := 'CLD' ;
  269.   mn[std ] := 'STD' ;   mn[cli ] := 'CLI' ;   mn[sti ] := 'STI' ;
  270.   mn[hlt ] := 'HLT' ;   mn[wait] := 'WAIT';   mn[esc ] := 'ESC' ;
  271.   mn[lock] := 'LOCK';
  272.   mn[valid] := '';
  273.   mn[db  ] := 'DB'  ;   mn[assume ] := 'ASSUME' ;
  274.   mn[dd  ] := 'DD'  ;   mn[comment] := 'COMMENT';
  275.   mn[dq  ] := 'DQ'  ;   mn[extrn  ] := 'EXTRN'  ;
  276.   mn[dt  ] := 'DT'  ;   mn[group  ] := 'GROUP'  ;
  277.   mn[dw  ] := 'DW'  ;   mn[include] := 'INCLUDE';
  278.   mn[end_] := 'END' ;   mn[label_ ] := 'LABEL'  ;
  279.   mn[equ ] := 'EQU' ;   mn[public ] := 'PUBLIC' ;
  280.   mn[even] := 'EVEN';   mn[record_] := 'RECORD' ;
  281.   mn[name] := 'NAME';   mn[segment] := 'SEGMENT';
  282.   mn[org ] := 'ORG' ;   mn[struc  ] := 'STRUC'  ;
  283.   mn[proc] := 'PROC';   mn[macro  ] := 'MACRO'  ;
  284.   mn[endm] := 'ENDM';   mn[subttl ] := 'SUBTTL' ;
  285.   mn[page] := 'PAGE';   mn[title  ] := 'TITLE'  ;
  286.   mn[fld   ] := 'FLD'   ;  mn[fst   ] := 'FST'   ;  mn[fstp  ] := 'FSTP'  ;
  287.   mn[fxch  ] := 'FXCH'  ;  mn[fcom  ] := 'FCOM'  ;  mn[fcomp ] := 'FCOMP' ;
  288.   mn[fcompp] := 'FCOMPP';  mn[ftst  ] := 'FTST'  ;  mn[fxam  ] := 'FXAM'  ;
  289.   mn[fadd  ] := 'FADD'  ;  mn[fsub  ] := 'FSUB'  ;  mn[fmul  ] := 'FMUL'  ;
  290.   mn[fdiv  ] := 'FDIV'  ;  mn[fsqrt ] := 'FSQRT' ;  mn[fscale] := 'FSCALE';
  291.   mn[fprem ] := 'FPREM' ;  mn[fabs  ] := 'FABS'  ;  mn[frndint] := 'FRNDINT';
  292.   mn[fchs  ] := 'FCHS'  ;  mn[fptan ] := 'FPTAN' ;  mn[fxtract] := 'FXTRACT';
  293.   mn[fpatan] := 'FPATAN';  mn[f2xm1 ] := 'F2XM1' ;  mn[fyl2x ] := 'FYL2X' ;
  294.   mn[fldz  ] := 'FLDZ'  ;  mn[fld1  ] := 'FLD1'  ;  mn[fyl2xp1] := 'FYL2XP1';
  295.   mn[fldpi ] := 'FLDPI' ;  mn[fldl2t] := 'FLDL2T';  mn[fldl2e] := 'FLDL2E';
  296.   mn[fldlg2] := 'FLDLG2';  mn[fldln2] := 'FLDLN2';  mn[finit ] := 'FINIT' ;
  297.   mn[feni  ] := 'FENI'  ;  mn[fdisi ] := 'FDISI' ;  mn[fldcw ] := 'FLDCW' ;
  298.   mn[fstcw ] := 'FSTCW' ;  mn[fstsw ] := 'FSTSW' ;  mn[fclex ] := 'FCLEX' ;
  299.   mn[fstenv] := 'FSTENV';  mn[fldenv] := 'FLDENV';  mn[fsave ] := 'FSAVE' ;
  300.   mn[frstor] := 'FRSTOR';  mn[ffree ] := 'FFREE' ;  mn[fincstp] := 'FINCSTP';
  301.   mn[fnop  ] := 'FNOP'  ;  mn[fwait ] := 'FWAIT' ;  mn[fdecstp] := 'FDECSTP';
  302.  
  303.   reg[ax] := 'AX';  reg[bx] := 'BX';  reg[cx] := 'CX';  reg[dx] := 'DX';
  304.   reg[sp] := 'SP';  reg[bp] := 'BP';  reg[si] := 'SI';  reg[di] := 'DI';
  305.   reg[al] := 'AL';  reg[bl] := 'BL';  reg[cl] := 'CL';  reg[dl] := 'DL';
  306.   reg[ah] := 'AH';  reg[bh] := 'BH';  reg[ch] := 'CH';  reg[dh] := 'DH';
  307.   reg[ds] := 'DS';  reg[ss] := 'SS';  reg[cs] := 'CS';  reg[es] := 'ES';
  308.   rn[ax] := 0;      rn[bx] := 3;      rn[cx] := 1;      rn[dx] := 2;
  309.   rn[sp] := 4;      rn[bp] := 5;      rn[si] := 6;      rn[di] := 7;
  310.   rn[al] := 0;      rn[bl] := 3;      rn[cl] := 1;      rn[dl] := 2;
  311.   rn[ah] := 4;      rn[bh] := 7;      rn[ch] := 5;      rn[dh] := 6;
  312.   rn[ds] := 3;      rn[ss] := 2;      rn[cs] := 1;      rn[es] := 0;
  313. end;   { init }
  314.  
  315. function search(symbol: idtype): boolean;     { search symbol table }
  316. begin                                         { return index in global n }
  317.   n := 0;
  318.   symbol := stupcase(symbol);
  319.   while (tab[n].id <> symbol) and (n <= tcnt) do n := n+1;
  320.   if n = tcnt+1
  321.   then search := false
  322.   else search := true;
  323. end;
  324.  
  325. procedure generate;                   { pass 2 -- maintain location counter }
  326.                                       { pass 3 -- generate object code }
  327. var
  328.   q0,w,md,rm: byte;
  329.   q1: integer;
  330.  
  331.   procedure oneop;         { test for exactly one operand }
  332.   begin
  333.       if op2.isop then error(11);
  334.       if not op1.isop then error(1);
  335.   end;
  336.  
  337.   procedure emit(q:byte);             { emit one byte }
  338.     function hex(d:byte): char;
  339.     begin
  340.       if d <= 9
  341.       then hex := chr(48+d)
  342.       else hex := chr(55+d);
  343.     end;
  344.   begin
  345.     loc := loc+1;
  346.     if (pass=3) and (errn = 0) then begin
  347.       if atstart then t := t+' ' else t := t+'/';
  348.       atstart := false;
  349.       t := t+'$'+hex(q shr 4)+hex(q and 15);
  350.     end;
  351.   end;
  352.  
  353.   procedure emit2(q:integer);         { emit two bytes }
  354.   begin
  355.     begin
  356.       emit(q and $ff);
  357.       emit(q shr 8);
  358.     end
  359.   end;
  360.  
  361.   procedure emitid(ident: idtype);    { emit identifier }
  362.   begin
  363.     loc := loc+2;
  364.     if (pass=3) and (errn = 0) then t := t+'/'+ident;
  365.   end;
  366.  
  367.   procedure emitimm(op:attr);         { emit immediate value }
  368.   begin
  369.   with op do
  370.     if isid then emitid(ident)
  371.     else if isconst then if (w=1) then emit2(value) else emit(value)
  372.     else error(10);
  373.   end;
  374.  
  375.   procedure checktype(op1,op2:attr);  { check compatibility of operands }
  376.   begin
  377.     if (op1.isword and not op2.isbyte) or (op2.isword and not op1.isbyte)
  378.     then w := 1
  379.     else if (op1.isbyte and not op2.isword) or (op2.isbyte and not op1.isword)
  380.          then w := 0
  381.     else if not (op1.isbyte or op1.isword or op2.isbyte or op2.isword)
  382.          then error(7)
  383.     else error(3);
  384.     if op1.issreg or op2.issreg then w := 0;
  385.   end;
  386.  
  387.   procedure modrm(q:byte; op:attr);       { construct the modregr/m byte }
  388.   begin
  389.   with op do begin
  390.     if isid then md := 2
  391.     else if isconst
  392.       then if (value <= 127) and (value >= -128) then md := 1 else md := 2
  393.     else md := 0;
  394.  
  395.     if isidx and isbase
  396.     then begin
  397.       if base = bx then rm := 0 else rm := 2;
  398.       if idx = di then rm := rm+1;
  399.       end
  400.     else if not isidx and not isbase
  401.     then begin
  402.       md := 0; rm := 6; end
  403.     else begin
  404.       rm := 4;
  405.       if isidx and (idx = di) then rm := rm+1;
  406.       if isbase
  407.       then if base = bp then rm := rm+2 else rm := rm+3;
  408.       end;
  409.       emit((md shl 6)+(q shl 3)+rm);
  410.       if isid then emitid(ident);
  411.       if isconst then begin
  412.         if (value <= 127) and (value >= -128) then begin
  413.           emit(value);
  414.           if (md=0) and (rm=6) then if value<0 then emit($ff) else emit(0);
  415.           end
  416.         else emit2(value);
  417.         end;
  418.   end; end;
  419.  
  420.   procedure regtoreg(q:byte; op1,op2:attr);
  421.   begin
  422.     checktype(op1,op2);
  423.     emit(q+w);
  424.     emit(192 + (rn[op1.rg] shl 3) + rn[op2.rg]);
  425.   end;
  426.  
  427.   procedure imtoacc(q:byte; op1,op2:attr);
  428.   begin
  429.     checktype(op1,op2);
  430.     emit(q+w);
  431.     emitimm(op2);
  432.   end;
  433.  
  434.   procedure imtoreg(q:byte; op1,op2:attr);
  435.   begin
  436.     if op1.isword and op2.isbyte then w := 1 else checktype(op1,op2);
  437.     emit(q+(w shl 3)+rn[op1.rg]);
  438.     emitimm(op2);
  439.   end;
  440.  
  441.   procedure onerm(q:byte; op:attr);
  442.   begin
  443.   with op do begin
  444.     if isreg
  445.     then emit(192+(q shl 3)+rn[rg])
  446.     else if isaddr then modrm(q,op)
  447.     else error(10);
  448.   end;
  449.   end;
  450.  
  451.   procedure imtorm(q,r:byte; op1,op2:attr; ext:boolean);
  452.   begin
  453.     if op1.isbyte and op2.isword then error(3)
  454.     else if op1.isbyte and op2.isbyte then w := 0
  455.     else if op1.isword and op2.isword then w := 1
  456.     else if op1.isword and op2.isbyte then if ext then w := 3 else w := 1
  457.     else if op1.isaddr and op2.isbyte then w := 0
  458.     else if op1.isaddr and op2.isword then w := 1
  459.     else error(29);
  460.     emit(q+w);
  461.     onerm(r,op1);
  462.     emitimm(op2);
  463.   end;
  464.  
  465.   procedure regmem(q: byte; op1,op2: attr);
  466.   begin
  467.     checktype(op1,op2);
  468.     emit(q+w);
  469.     modrm(rn[op1.rg],op2);
  470.   end;
  471.  
  472.   procedure inout(q:byte; op1,op2:attr);
  473.   begin
  474.     if not (op1.isreg and (op1.rg in [ax,al])) then error(10);
  475.     if op1.rg=ax then w := 1 else w := 0;
  476.     if op2.isconst then begin
  477.       if op2.isidx or op2.isbase then error(10);
  478.       if (op2.value < 0) or (op2.value > 255) then error(12);
  479.       emit(q+w);
  480.       emit(op2.value);
  481.       end
  482.     else if op2.isreg and (op2.rg=dx) then emit(q+8+w)
  483.     else error(10);
  484.   end;
  485.  
  486. begin   { generate }
  487.   t := ''; errn := codpnt^.errn;
  488.   op1 := codpnt^.op1; op2 := codpnt^.op2;
  489.   with codpnt^ do begin
  490.   if errn=0 then begin
  491.     if repx in [rep,repne,repnz] then emit($f2);
  492.     if repx in [repe,repz] then emit($f3);
  493.     if lockx then emit($f0);
  494.     if override in [ds,cs,ss,es] then emit($26+(rn[override] shl 3));
  495.  
  496.     case op of
  497.  
  498.    nul: ;
  499.  
  500.    mov: begin
  501.       w := 1;
  502.       if not (op1.isop and op2.isop)
  503.       then error(1)
  504.       else if op1.issreg then begin
  505.           if op1.rg=cs then error(10);
  506.           q0 := $8e;
  507.           if op2.isreg then regtoreg(q0,op1,op2)
  508.           else if op2.isaddr then regmem(q0,op1,op2)
  509.           else error(10);
  510.         end
  511.       else if op2.issreg then begin
  512.           q0 := $8c;
  513.           if op1.isreg then regtoreg(q0,op2,op1)
  514.           else if op1.isaddr then regmem(q0,op2,op1)
  515.           else error(10);
  516.         end
  517.       else if op2.isimmed then begin
  518.           if op1.isreg
  519.           then imtoreg($b0,op1,op2)
  520.           else imtorm($c6,0,op1,op2,false);
  521.         end
  522.       else if op1.isreg and (op1.rg in [ax,al]) and op2.isaddr
  523.               and not op2.isbase and not op2.isidx then begin
  524.           if op1.rg = ax then emit($a1) else emit($a0);
  525.           emitimm(op2);
  526.         end
  527.       else if op2.isreg and (op2.rg in [ax,al]) and op1.isaddr
  528.               and not op1.isbase and not op1.isidx then begin
  529.           if op2.rg = ax then emit($a3) else emit($a2);
  530.           emitimm(op1);
  531.         end
  532.       else if op1.isreg and op2.isreg then begin
  533.           q0 := $8a;
  534.           regtoreg(q0,op1,op2); end
  535.       else if (op1.isreg and op2.isaddr) or (op1.isaddr and op2.isreg)
  536.         then begin
  537.           q0 := $88;
  538.           if op1.isaddr
  539.           then regmem(q0,op2,op1)
  540.           else begin
  541.             q0 := q0+2;
  542.             regmem(q0,op1,op2)
  543.             end
  544.         end
  545.       else error(10);
  546.     end;
  547.  
  548.    add,adc,sub,sbb,cmp,and_,or_,xor_,test_:
  549.     begin
  550.       if not (op1.isop and op2.isop)
  551.       then error(1)
  552.       else
  553.       if op2.isimmed
  554.       then if op1.isreg and ((op1.rg=ax) or (op1.rg=al))
  555.            then begin
  556.              if op1.isword then op2.isbyte := false;
  557.              case op of
  558.             add: q0 := $04;
  559.             adc: q0 := $14;
  560.             sub: q0 := $2c;
  561.             sbb: q0 := $1c;
  562.             cmp: q0 := $3c;
  563.             and_: q0 := $24;
  564.             or_ : q0 := $0c;
  565.             xor_: q0 := $34;
  566.             test_: q0 := $a8;
  567.              end;
  568.              imtoacc(q0,op1,op2);
  569.            end
  570.            else begin
  571.              q0 := $80;
  572.              case op of
  573.             add: q1 := 0;
  574.             adc: q1 := 2;
  575.             sub: q1 := 5;
  576.             sbb: q1 := 3;
  577.             cmp: q1 := 7;
  578.             and_: q1 := 4;
  579.             or_ : q1 := 1;
  580.             xor_: q1 := 6;
  581.             test_: begin q0 := $f6; q1 := 0; end;
  582.              end;
  583.              if op in [add,adc,sub,sbb,cmp]
  584.              then imtorm(q0,q1,op1,op2,true)
  585.              else imtorm(q0,q1,op1,op2,false);
  586.            end
  587.  
  588.       else if op1.isreg and op2.isreg
  589.            then begin
  590.              case op of
  591.             add: q0 := $02;
  592.             adc: q0 := $12;
  593.             sub: q0 := $2a;
  594.             sbb: q0 := $1a;
  595.             cmp: q0 := $3a;
  596.             and_: q0 := $22;
  597.             or_ : q0 := $0a;
  598.             xor_: q0 := $32;
  599.             test_: q0 := $84;
  600.              end;
  601.              regtoreg(q0,op1,op2);
  602.            end
  603.       else if (op1.isaddr and op2.isreg) or (op1.isreg and op2.isaddr)
  604.            then begin
  605.              case op of
  606.             add: q0 := $00;
  607.             adc: q0 := $10;
  608.             sub: q0 := $28;
  609.             sbb: q0 := $18;
  610.             cmp: q0 := $38;
  611.             and_: q0 := $20;
  612.             or_ : q0 := $08;
  613.             xor_: q0 := $30;
  614.             test_: q0 := $84;
  615.              end;
  616.              if op1.isaddr
  617.              then regmem(q0,op2,op1)
  618.              else begin
  619.                if op<>test_ then q0 := q0+2;
  620.                regmem(q0,op1,op2)
  621.                end
  622.            end
  623.       else error(10);
  624.     end;
  625.  
  626.    push,pop:
  627.     begin
  628.     with op1 do begin
  629.       oneop;
  630.       if issreg then begin
  631.         if (op=pop) and (rg=cs) then error(10);
  632.         case op of
  633.        push: q0 := $06;
  634.        pop:  q0 := $07;
  635.         end;
  636.         emit(q0+(rn[rg] shl 3));
  637.         end
  638.       else if isreg then begin
  639.         if not isword then error(3);
  640.         case op of
  641.        push: q0 := $50;
  642.        pop:  q0 := $58;
  643.         end;
  644.         emit(q0+rn[rg]);
  645.         end
  646.       else if isaddr then begin
  647.         if isbyte then error(3);
  648.         case op of
  649.        push: begin q0 := $ff; q1 := 6; end;
  650.        pop:  begin q0 := $8f; q1 := 0; end;
  651.         end;
  652.         emit(q0);
  653.         onerm(q1,op1);
  654.         end
  655.       else error(10);
  656.     end;
  657.     end;
  658.  
  659.    inc,dec:
  660.     begin
  661.     with op1 do begin
  662.       oneop;
  663.       if isreg and isword then begin
  664.         case op of
  665.        inc: q0 := $40;
  666.        dec: q0 := $48;
  667.         end;
  668.         emit(q0+rn[rg]);
  669.         end
  670.       else if isaddr or isreg then begin
  671.         if isbyte then w := 0
  672.         else if isword then w := 1
  673.         else error(7);
  674.         case op of
  675.        inc: q1 := 0;
  676.        dec: q1 := 1;
  677.         end;
  678.         emit($fe+w);
  679.         onerm(q1,op1);
  680.         end
  681.       else error(10);
  682.     end;
  683.     end;
  684.  
  685.    xchg:
  686.     begin
  687.       if not op2.isop then error(1);
  688.       if op1.isreg and op2.isreg and ((op1.rg=ax) or (op2.rg=ax))
  689.       then begin
  690.         if op1.rg<>ax
  691.         then emit($90+rn[op1.rg])
  692.         else emit($90+rn[op2.rg]);
  693.         end
  694.       else if op1.isreg and op2.isreg
  695.       then regtoreg($86,op1,op2)
  696.       else if op1.isreg and op2.isaddr
  697.       then regmem($86,op1,op2)
  698.       else if op1.isaddr and op2.isreg
  699.       then regmem($86,op2,op1)
  700.       else error(10);
  701.     end;
  702.  
  703.    mul,imul,div_,idiv,neg,not_:
  704.     begin
  705.       oneop;
  706.       if op1.isbyte then q0 := $f6
  707.       else if op1.isword then q0 := $f7
  708.       else error(7);
  709.       case op of
  710.      mul:  q1 := 4;
  711.      imul: q1 := 5;
  712.      div_:  q1 := 6;
  713.      idiv: q1 := 7;
  714.      neg:  q1 := 3;
  715.      not_:  q1 := 2;
  716.       end;
  717.       emit(q0);
  718.       onerm(q1,op1);
  719.     end;
  720.  
  721.    in_: inout($e4,op1,op2);
  722.    out: inout($e6,op2,op1);
  723.  
  724.    lea,lds,les:
  725.     begin
  726.       if not op2.isop then error(1);
  727.       if not(op1.isreg and op1.isword and op2.isaddr) then error(10);
  728.       case op of
  729.      lea: q0 := $8d;
  730.      lds: q0 := $c5;
  731.      les: q0 := $c4;
  732.       end;
  733.       emit(q0);
  734.       onerm(rn[op1.rg],op2);
  735.     end;
  736.  
  737.    shl_,sal,shr_,sar,rol,ror,rcl,rcr:
  738.     begin
  739.     with op2 do begin
  740.       if not isop then error(1);
  741.       if isidx or isbase then error(10);
  742.       if isconst and (value=1) then q0 := $d0
  743.       else if isreg and (rg=cl) then q0 := $d2
  744.       else error(10);
  745.       case op of
  746.      shl_,sal: q1 := 4;
  747.      shr_: q1 := 5;
  748.      sar: q1 := 7;
  749.      rol: q1 := 0;
  750.      ror: q1 := 1;
  751.      rcl: q1 := 2;
  752.      rcr: q1 := 3;
  753.       end;
  754.       if op1.isword
  755.       then q0 := q0+1
  756.       else if not op1.isbyte then error(7);
  757.       if not(op1.isreg or op1.isaddr) then error(10);
  758.       emit(q0);
  759.       onerm(q1,op1);
  760.     end;
  761.     end;
  762.  
  763.    lods,stos,scas:
  764.     begin
  765.     with op1 do begin
  766.       if op2.isop then error(11);
  767.       if not op1.isop then error(7);
  768.       case op of
  769.      lods: q0 := $ac;
  770.      stos: q0 := $aa;
  771.      scas: q0 := $ae;
  772.       end;
  773.       if isword then q0 := q0+1 else if not isbyte then error(7);
  774.       if isbase or isimmed or isreg then error(10);
  775.       if isidx and (((idx=si) and (op in [stos,scas]))
  776.                     or ((idx=di) and (op=lods))) then error(10);
  777.       emit(q0);
  778.     end; end;
  779.  
  780.    movs,cmps:
  781.     begin
  782.       if op2.isop then begin
  783.         checktype(op1,op2);
  784.         if op2.isidx and (((op2.idx=di) and (op=movs))
  785.            or ((op2.idx=si) and (op=cmps))) then error(10);
  786.         if op2.isbase or op2.isimmed or op2.isreg then error(10);
  787.         end
  788.       else if op1.isop then begin
  789.         if op1.isword then w := 1
  790.         else if op1.isbyte then w := 0
  791.         else error(7);
  792.         if op1.isimmed or op1.isreg or op1.isaddr then error(10);
  793.         end
  794.       else error(7);
  795.       if op1.isop then begin
  796.         if op1.isbase or op1.isimmed or op1.isreg then error(10);
  797.         if op1.isidx and (((op1.idx=si) and (op=movs))
  798.            or ((op1.idx=di) and (op=cmps))) then error(10);
  799.         end;
  800.       case op of
  801.      movs: emit($a4+w);
  802.      cmps: emit($a6+w);
  803.       end;
  804.     end;
  805.  
  806.    ret:
  807.     begin
  808.       if op2.isop then error(11);
  809.       if not op1.isop then error(1);
  810.       with op1 do begin
  811.         if isidx or isbase or isreg or isid then error(10);
  812.         if isconst then q0 := $c2 else q0 := $c3;
  813.         if isfar then q0 := q0+8
  814.         else if not isnear
  815.           then if isshort then error(10) else error(7);
  816.         emit(q0);
  817.         if isconst then emit2(value);
  818.       end
  819.     end;
  820.  
  821.    jmp,call:
  822.     begin
  823.     with op1 do begin
  824.       w := 1;
  825.       if op2.isop then begin
  826.         if not (isimmed and op2.isimmed) then error(10);
  827.         if isnear or op2.isnear then error(3);
  828.         case op of
  829.        jmp:  emit($ea);
  830.        call: emit($9a);
  831.         end;
  832.         emitimm(op1);
  833.         emitimm(op2);
  834.         end
  835.       else if not op1.isop then error(1)
  836.       else if isfar then begin
  837.         if (not isaddr) or (isid and search(ident)) then error(10);
  838.         emit($ff);
  839.         case op of
  840.        jmp:  onerm(5,op1);
  841.        call: onerm(3,op1);
  842.         end;
  843.         end
  844.       else if isimmed and isconst then begin
  845.         if (value<=127) and (value>=-128) and (op=jmp)
  846.         then begin emit($eb); emit(value); end
  847.         else begin
  848.           case op of
  849.          jmp:  emit($e9);
  850.          call: emit($e8);
  851.           end;
  852.           emitimm(op1); end;
  853.         end
  854.       else if isid and search(ident) then begin
  855.         if isidx or isbase then error(2);
  856.         q1 := tab[n].val-loc-2;
  857.         if pass=3 then begin
  858.           if (op=jmp) and (q1 >= -128) and (q1 <= 127)
  859.           then begin
  860.             emit($eb);
  861.             if isshort then emit(q1)
  862.             else begin emit(q1); emit($90); end;
  863.             end
  864.           else begin
  865.             case op of
  866.            jmp:  begin
  867.               if isshort then error(17);
  868.               emit($e9); end;
  869.            call: begin
  870.               if isshort then error(10);
  871.               emit($e8); end;
  872.             end;
  873.             emit2(q1-1);
  874.             end;
  875.           end
  876.         else begin  {pass2}
  877.             if (op=jmp) and (isshort or ((tab[n].val > -1) and (q1 > -128)))
  878.             then begin emit2(0); isshort := true; end
  879.             else begin emit2(0); emit(0); end;
  880.           end;
  881.         end
  882.       else if (isreg or isaddr) and not (isbyte or isshort) then begin
  883.         if not (isnear or isreg) then error(7);
  884.         emit($ff);
  885.         case op of
  886.        jmp:  onerm(4,op1);
  887.        call: onerm(2,op1);
  888.         end;
  889.         end
  890.       else error(10);
  891.     end;
  892.     end;
  893.  
  894.    je,jz,jl,jnge,jle,jng,jb,jnae,jbe,jna,jp,jpe,jo,js,jne,jnz,jnl,jge,jnle,
  895.    jg,jnb,jae,jnbe,ja,jnp,jpo,jno,jns,loop,loopz,loope,loopnz,loopne,jcxz:
  896.     begin
  897.       oneop;
  898.       with op1 do begin
  899.       if (isimmed and isconst)
  900.       then if not ((value>=-128) and (value<=127)) then error(12) else
  901.       else if not (isid and not (isidx or isbase)) then error(10);
  902.       case op of
  903.      je,jz:   q0 := $74;
  904.      jl,jnge: q0 := $7c;
  905.      jle,jng: q0 := $7e;
  906.      jb,jnae: q0 := $72;
  907.      jbe,jna: q0 := $76;
  908.      jp,jpe:  q0 := $7a;
  909.      jo:      q0 := $70;
  910.      js:      q0 := $78;
  911.      jne,jnz: q0 := $75;
  912.      jnl,jge: q0 := $7d;
  913.      jnle,jg: q0 := $7f;
  914.      jnb,jae: q0 := $73;
  915.      jnbe,ja: q0 := $77;
  916.      jnp,jpo: q0 := $7b;
  917.      jno:     q0 := $71;
  918.      jns:     q0 := $79;
  919.      loop:          q0 := $e2;
  920.      loopz,loope:   q0 := $e1;
  921.      loopnz,loopne: q0 := $e0;
  922.      jcxz:          q0 := $e3;
  923.       end;
  924.       if isconst
  925.       then begin emit(q0); emit(value); end
  926.       else begin
  927.         if (pass=3) and not search(ident) then error(16);
  928.         q1 := tab[n].val-loc-2;
  929.         if (pass=3) and ((q1 < -128) or (q1 > 127)) then error(17);
  930.         emit(q0);
  931.         emit(q1);
  932.         end;
  933.       end;
  934.     end;
  935.  
  936.    int:
  937.     begin
  938.     with op1 do begin
  939.       oneop;
  940.       if isidx or isbase or not isconst then error(10);
  941.       if (value < 0) or (value > 255) then error(12);
  942.       if value=3 then emit($cc)
  943.       else begin emit($cd); emit(value); end;
  944.     end;
  945.     end;
  946.  
  947.    esc:
  948.     begin
  949.       if not op2.isop then error(1);
  950.       if not op1.isimmed then error(10);
  951.       if (op1.value < 0) or (op1.value > 63) then error(10);
  952.       emit($d8+(op1.value shr 3));
  953.       onerm((op1.value and 7),op2);
  954.     end;
  955.  
  956.    xlat,lahf,sahf,pushf,popf,aaa,daa,aas,das,cbw,cwd,into,iret,clc,cmc,
  957.    stc,cld,std,cli,sti,hlt,wait,aam,aad,nop:
  958.     begin
  959.       if op1.isop then error(11);
  960.       case op of
  961.      xlat: emit($d7);
  962.      lahf: emit($9f);
  963.      sahf: emit($9e);
  964.      pushf:emit($9c);
  965.      popf: emit($9d);
  966.      aaa:  emit($37);
  967.      daa:  emit($27);
  968.      aas:  emit($3f);
  969.      das:  emit($2f);
  970.      cbw:  emit($98);
  971.      cwd:  emit($99);
  972.      into: emit($ce);
  973.      iret: emit($cf);
  974.      clc:  emit($f8);
  975.      cmc:  emit($f5);
  976.      stc:  emit($f9);
  977.      cld:  emit($fc);
  978.      std:  emit($fd);
  979.      cli:  emit($fa);
  980.      sti:  emit($fb);
  981.      hlt:  emit($f4);
  982.      wait: emit($9b);
  983.      aam:  begin emit($d4); emit($0a); end;
  984.      aad:  begin emit($d5); emit($0a); end;
  985.      nop:  emit($90);
  986.       end;
  987.     end;
  988.  
  989.     else error(29);
  990.     end; { case op }
  991.   end; { if errn }
  992.  
  993.   if pass=3 then begin                { finish constructing the target line }
  994.     if codpnt = firstentry
  995.     then begin
  996.       writeln(targ,'Inline(');
  997.       writeln; writeln('Inline('); end;
  998.     message;
  999.     if next = nil then  t := t + '  );';
  1000.     while length(t) < 25 do t := t+' ';
  1001.     t := t + '   { ' + source;
  1002.     if length(t) < oldlen-4          { make it look pretty }
  1003.     then begin
  1004.       if length(t) > oldlen-8 then oldlen := oldlen+2;
  1005.       while length(t) < oldlen-4 do t := t+' ';
  1006.       end;
  1007.     t := t+' }';
  1008.     oldlen := length(t);
  1009.     writeln(targ,t); writeln(t);     { and write it to the file }
  1010.     codpnt := next;
  1011.   end;
  1012.  
  1013. end; {with}
  1014. end; { generate }
  1015.  
  1016.  
  1017. procedure address;         { compute address of each label }
  1018.  
  1019. begin
  1020.   if codpnt^.labeln <> 0
  1021.   then tab[codpnt^.labeln].val := loc;
  1022.   generate;                { advance location counter }
  1023.   codpnt^.errn := errn;
  1024.   codpnt := codpnt^.next;
  1025. end;
  1026.  
  1027.  
  1028. procedure parse_line;       { scan source and build intermediate code }
  1029.  
  1030. var
  1031.   s: line;       { source line }
  1032.   p: integer;    { index into s }
  1033.   m: idtype;     { mnemonic opcode }
  1034.   labeln: integer;
  1035.   temp: line;
  1036.   id: idtype;    { identifier }
  1037.   preventry: cptr;    { points to previous line of intermediate code }
  1038.  
  1039. label nocode;
  1040.  
  1041.   function more: boolean;      { any more characters on this line? }
  1042.   begin
  1043.     more := p <= length(s);
  1044.   end;
  1045.  
  1046.   procedure skipblank;
  1047.   begin
  1048.     while more and (s[p] = ' ') do
  1049.     p := p+1;
  1050.   end;
  1051.  
  1052.   function alpha: boolean;
  1053.   begin
  1054.     alpha := more and (s[p] in ['a'..'z','A'..'Z']);
  1055.   end;
  1056.  
  1057.   function digit: boolean;
  1058.   begin
  1059.     digit := more and (s[p] in ['0'..'9']);
  1060.   end;
  1061.  
  1062.   function peek(aset: charset): boolean;   { is next character in aset? }
  1063.   begin
  1064.     if more and (s[p] in aset) then peek := true else peek := false;
  1065.   end;
  1066.  
  1067.   function test(c: char): boolean;       { is the next character c? }
  1068.   begin                                  { if so, scan over it      }
  1069.     if more and (upcase(s[p]) = c)
  1070.     then begin
  1071.       p := p+1; skipblank;
  1072.       test := true
  1073.       end
  1074.     else test := false
  1075.   end;
  1076.  
  1077.   procedure getid;               { found an alpha }
  1078.   begin                          { get rest of identifier }
  1079.     id := '';
  1080.     while alpha or digit or peek(['_']) do begin
  1081.       if length(id) < 20
  1082.       then id := id + s[p]       { return it in id }
  1083.       else error(14);
  1084.       p := p+1;
  1085.     end;
  1086.     skipblank;
  1087.   end;
  1088.  
  1089.   procedure enter(symbol: idtype; var m: integer);
  1090.                                { make entry in symbol table }
  1091.   begin
  1092.     if search(symbol)
  1093.     then error(15)
  1094.     else if tcnt = tsize then begin
  1095.       writeln; writeln('Assembly Aborted -- Symbol Table Full');
  1096.       close(src); close(targ);
  1097.       halt; end
  1098.     else begin
  1099.       tcnt := tcnt+1;
  1100.       tab[tcnt].id := stupcase(symbol);
  1101.       tab[tcnt].val := -1;
  1102.       m := tcnt;
  1103.     end;
  1104.   end;
  1105.  
  1106.   function code: boolean;            { found an id }
  1107.                                      { is it an opcode? }
  1108.   begin
  1109.     op := nul;
  1110.     m := stupcase(id);
  1111.     repeat                           { if so, return it in op }
  1112.       op := succ(op)
  1113.     until (mn[op] = m) or (op = last);
  1114.     if op in [rep,repe,repz,repne,repnz] then begin
  1115.       if repx <> nul then error(13);
  1116.       repx := op;                      { REP prefix }
  1117.       if alpha then begin              { look for another opcode }
  1118.         getid;
  1119.         code := code; end
  1120.       else error(4);
  1121.       end
  1122.     else if op=lock then begin
  1123.       if lockx then error(13);
  1124.       lockx := true;                   { LOCK prefix }
  1125.       if alpha then begin              { look for another opcode }
  1126.         getid;
  1127.         code := code; end
  1128.       else error(4);
  1129.       end
  1130.     else if (op > valid) and (op <> last) then error(18)
  1131.     else if op <> last then begin
  1132.       code := true;
  1133.       if (repx<>nul) and not (op in [movs,cmps,scas,lods,stos]) then error(4);
  1134.       end
  1135.     else begin code := false; op := nul; end;
  1136.   end;  { code }
  1137.  
  1138.   procedure getoperand(var opr: attr);    { scan an operand }
  1139.                                           { determine its attributes }
  1140.   var r: regs;
  1141.  
  1142.   label gotid;
  1143.  
  1144.     procedure makebyte;         { it's a byte }
  1145.     begin
  1146.       if opr.isword then error(3) else opr.isbyte := true;
  1147.     end;
  1148.  
  1149.     procedure makeword;         { it's a word }
  1150.     begin
  1151.       if opr.isbyte then error(3) else opr.isword := true;
  1152.     end;
  1153.  
  1154.     procedure getnum;           { scan a numeric literal }
  1155.  
  1156.     var code: integer;
  1157.         minus: boolean;
  1158.  
  1159.       procedure gethex;           { scan a hexadecimal literal }
  1160.       begin
  1161.         if id = '-' then minus := true;
  1162.         id := '$'; p := p+1;
  1163.         while more and (digit or (upcase(s[p]) in ['A','B','C','D','E','F']))
  1164.         do begin
  1165.           id := id + s[p];        { return it in id }
  1166.           p := p+1;
  1167.         end;
  1168.         if id = '$' then error(2);
  1169.       end;
  1170.  
  1171.     begin
  1172.       id := ''; minus := false;
  1173.       if test('+') then;
  1174.       if test('-') then id := '-';
  1175.       if peek(['$'])
  1176.       then gethex                          { hex }
  1177.       else while digit do begin            { decimal }
  1178.         id := id + s[p];
  1179.         p := p+1;
  1180.       end;
  1181.       if id = '' then error(2);
  1182.       with opr do begin
  1183.         val(id,value,code);              { return value }
  1184.         if code<>0
  1185.         then if id='-32768'
  1186.           then value := $8000
  1187.           else error(9);
  1188.         if minus then value := -value
  1189.       end;
  1190.       if id[1] = '-' then delete(id,1,1);
  1191.       skipblank;
  1192.     end;   { getnum }
  1193.  
  1194.  
  1195.     procedure getchar;          { scan a character literal }
  1196.     begin
  1197.       with opr do begin
  1198.       p := p+1;
  1199.       value := ord(s[p]); p := p+1;
  1200.       if not test('''') then error(2)
  1201.       else begin
  1202.         isconst := true;
  1203.         isimmed := true;
  1204.         if not isword then isbyte := true;
  1205.       end;
  1206.     end; end;
  1207.  
  1208.     function testreg: boolean;        { is id a register name? }
  1209.     begin
  1210.       r := firstreg;
  1211.       temp := stupcase(id);
  1212.       repeat
  1213.         r := succ(r)                  { if so, return register number in r }
  1214.       until (reg[r] = temp) or (r = lastreg);
  1215.       if r <> lastreg then testreg := true else testreg := false;
  1216.     end;
  1217.  
  1218.  
  1219.   begin  {getoperand}
  1220.     with opr do begin
  1221.     isop := true;
  1222.     if not (alpha or digit or peek(['=','$','*','[','+','-','(','''']))
  1223.     then error(2)
  1224.     else begin
  1225.       if alpha then begin
  1226.         getid;
  1227.         if testreg and (r in [ds,cs,ss,es]) and peek([':'])
  1228.         then begin                                { segment override prefix }
  1229.           if test(':') then;
  1230.           if override<>lastreg then error(13);
  1231.           override := r; end
  1232.         else goto gotid;
  1233.         end;
  1234.       if test('(') then begin                     { type modifier }
  1235.         if test('B') then makebyte
  1236.         else if test('W') then makeword
  1237.         else if test('S') then isshort := true
  1238.         else if test('N') then isnear := true
  1239.         else if test('F') then isfar := true
  1240.         else error(6);
  1241.         if not test(')') then error(6);
  1242.         end;
  1243.       if test('=') then isimmed := true;
  1244.       if test('[')
  1245.       then begin                                  { base or index register }
  1246.         if isimmed then error(2);
  1247.         isaddr := true;
  1248.         getid;
  1249.         if testreg
  1250.         then begin
  1251.           if not test(']') then error(6);
  1252.           if r in [bx,bp]
  1253.           then begin                              { base register }
  1254.             isbase := true; isop := true;
  1255.             base := r;
  1256.             if test('[')
  1257.             then begin
  1258.               getid;
  1259.               if testreg
  1260.               then begin
  1261.                 if not test(']') then error(6);
  1262.                 if r in [si,di]
  1263.                 then begin                        { and index register }
  1264.                   isidx := true;
  1265.                   idx := r;
  1266.                   end
  1267.                 else error(8)
  1268.                 end
  1269.               else error(5)
  1270.               end
  1271.             end
  1272.           else if r in [si,di]
  1273.             then begin                            { index register }
  1274.               isidx := true;
  1275.               idx := r;
  1276.             end
  1277.           else error(8);
  1278.           end
  1279.         else error(5)
  1280.         end;
  1281.       if alpha
  1282.       then begin                                  { identifier }
  1283.         getid;
  1284. gotid:  if testreg
  1285.         then begin                                { it's a register }
  1286.           if r in [ds,ss,cs,es]
  1287.           then issreg := true
  1288.           else isreg := true;
  1289.           if r in [ax,bx,cx,dx,sp,bp,si,di,ds,ss,cs,es]
  1290.           then makeword;
  1291.           if r in [ah,bh,ch,dh,al,bl,cl,dl]
  1292.           then makebyte;
  1293.           if isimmed then error(2);
  1294.           rg := r;
  1295.           end
  1296.         else begin                              { it's a variable or label id }
  1297.           isaddr := not isimmed;
  1298.           isid := true;
  1299.           ident := id;
  1300.           if isimmed then makeword;
  1301.           end;
  1302.       end  {alpha}
  1303.       else if digit or peek(['$','+','-'])
  1304.       then begin                                  { numeric literal }
  1305.         getnum;
  1306.         isaddr := not isimmed;
  1307.         isconst := true;
  1308.         if isimmed
  1309.         then if (value <= 255) and (value >= -128) and not isword
  1310.              then makebyte
  1311.              else makeword;
  1312.       end
  1313.       else if test('*')
  1314.       then begin                                { location counter reference }
  1315.         ident := '*';
  1316.         isaddr := not isimmed;
  1317.         isid := true;
  1318.         if isimmed then makeword;
  1319.         if test('+') then ident := '*+';
  1320.         if test('-') then ident := '*-';
  1321.         if ident<>'*' then begin
  1322.           if not peek(['$','0'..'9']) then error(9);
  1323.           getnum;
  1324.           ident := ident + id;
  1325.         end;
  1326.       end
  1327.       else if peek(['''']) then getchar;        { character literal }
  1328.     if isbase and (base=bp) and not isidx and not (isid or isconst)
  1329.     then begin
  1330.       isconst := true; value := 0;
  1331.       ident := '$00';
  1332.       end;
  1333.     end;
  1334.     if isimmed and not (isid or isconst) then error(6);
  1335.     end; {with}
  1336.     skipblank;
  1337.   end;   {getoperand}
  1338.  
  1339.  
  1340. begin    { parse_line }
  1341.   errn := 0; labeln := 0;
  1342.   op := nul; repx := nul; lockx := false; override := lastreg;
  1343.   with op1 do begin
  1344.       isop := false; isaddr := false;
  1345.       isid := false; isreg := false; issreg := false;
  1346.       isidx := false; isbase := false;
  1347.       isbyte := false; isword := false;
  1348.       isshort := false; isnear := false; isfar := false;
  1349.       isimmed := false; isconst := false;
  1350.     end;
  1351.   op2 := op1;
  1352.   readln(src,s);                       { read in a source line }
  1353.   for p := 1 to length(s) do
  1354.     if ord(s[p]) < 32 then s[p] := ' ';
  1355.   p := 1;
  1356.   if more
  1357.   then begin
  1358.     skipblank;
  1359.     if alpha then begin
  1360.       getid;
  1361.       if test(':') then begin                               { label }
  1362.         enter(id,labeln);
  1363.         if alpha
  1364.         then getid
  1365.         else goto nocode;
  1366.         end;
  1367.       if code                                             { opcode }
  1368.       then begin
  1369.         if more and not peek([';'])
  1370.         then begin
  1371.           getoperand(op1);                               { first operand }
  1372.           if test(',')
  1373.           then begin
  1374.             if more
  1375.             then getoperand(op2)                         { second operand }
  1376.             else error(6);
  1377.             if more and not peek([';']) then error(6);
  1378.             end
  1379.           else if more and not peek([';']) then error(6);
  1380.           end
  1381.         end
  1382.         else error(4)
  1383.       end
  1384.     else
  1385. nocode: if more and not peek([';']) then error(6);
  1386.   preventry := codpnt;
  1387.   if maxavail > sizeof(codrec) shr 4 +1
  1388.   then new(codpnt)                    { create new line of intermediate code }
  1389.   else begin
  1390.     writeln; writeln('Assembly Aborted -- Out of Memory');
  1391.     close(src); close(targ); halt; end;
  1392.   if firstentry = nil then firstentry := codpnt;
  1393.   preventry^.next := codpnt;                                { and link it }
  1394.   codpnt^.next := nil;
  1395.   codpnt^.labeln := labeln;
  1396.   codpnt^.op := op;                                { enter the data }
  1397.   codpnt^.op1 := op1;
  1398.   codpnt^.op2 := op2;
  1399.   codpnt^.repx := repx;
  1400.   codpnt^.lockx := lockx;
  1401.   codpnt^.override := override;
  1402.   codpnt^.errn := errn;
  1403.   codpnt^.source := s;
  1404.   end;
  1405. end;  { parse_line }
  1406.  
  1407.  
  1408. begin  { main }
  1409.   writeln('                    InLiner'); writeln;
  1410.   startup;
  1411.   init;
  1412.   atstart := true; ok := true;
  1413.   oldlen := 0; loc := 0; tcnt := 0;
  1414.  
  1415.   pass := 1; firstentry := nil;
  1416.   while not eof(src) do parse_line;
  1417.  
  1418.   pass := 2; codpnt := firstentry; loc := 0;
  1419.   while codpnt <> nil do address;
  1420.  
  1421.   pass := 3; codpnt := firstentry; loc := 0;
  1422.   while codpnt <> nil do generate;
  1423.  
  1424.   writeln;
  1425.   if ok then writeln('Assembly Successful')
  1426.         else writeln('Assembled with Errors');
  1427.   close(src); close(targ);
  1428. end.
  1429.